' ////////////////////////////////////////////////////////////////////
' FileName: SoftwareMeteringCLS.vbs
' ////////////////////////////////////////////////////////////////////
If (WScript.ScriptName = "SoftwareMeteringCLS.vbs") Then Call demo_SoftwareMeteringCLS()
' ====================================================================
Function getSoftwareList(sHost)
' Callable by *.wsf; will return list (safe array) of installed 
' software on the sHost system (sHost is ComputerName or IP address).
' 
' The assumption is that sHost is available and has WMI installed.
 Set oSoftMeter = new SoftwareMeteringCLS
 sProgsAry = oSoftMeter.getList(sHost)
 Set oSpftMeter = Nothing
 getSoftwareList = sProgsAry
End Function
' ====================== CLASS =======================================
Class SoftwareMeteringCLS
' Author:  Branimir Petrovic
' Date:  6 Sept 2002
' Version: 1.0.3
'
' Revision History:
'  30 March 2002    V 1.0.0
'
'  08 April 2002    V 1.0.1
'    Added error handling - if the target system is not present,
'    or does not have WMI, getList(sHost) will return empty list.
'
'    Added global function getSoftwareList(sHost) to be used
'    from *.wsf scripts when caller script is JScript (since
'    JScript can not instantiate VBS classes directly).
'
'  21 April 2002    V 1.0.2
'    Replacing "[" with "(" and "]" with ")" in "DisplayName"
'    Some strings like: [See Q311401 for more information] 
'    can cause troubles, therefore replacement.
'
'  6 Sept 2002     V 1.0.3
'    Win2K's SP3 for Windows 2000 introduced slight (but silent)
'    'improvement' in a way registry provder's EnumValues method
'    deals with empty keys. EnumValues method called against 
'    keys without any values (except the Default, empty value)
'    will now return Null value (previously array of size 0 was
'    returned). Added (previously unneeded) type checking...
'
' 
' Dependancies:
'  WSH 5.6
'
' Methods:
'  - getClassName()
'  - getVersion()
'  - getList(sHost) sHost parameter can be computer name or IP address
'   Enumerates all subkeys in: 
'    "Software\Microsoft\Windows\CurrentVersion\Uninstall"
'   Returns array of strings, each string item containing:
'    "DisplayNameKeyValue[ --Version: DisplayVersionKeyValue]"
'
'   If sHost parameter is empty string or non-string value,
'   function returns list of installed software on this host.
'   Otherwise it will connect to host pointed to by sHost string
'   (provided sufficient level of permissions)
'
'  - getHostString() Returns name of the system or IP address

 ' --- Private data members
 Private HKLM   ' Points to HKEY_LOCAL_MACHINE hive
 Private UNINSTALL_ROOT  ' Software\Microsoft\Windows\CurrentVersion\Uninstall
 Private SUPRESS_HOTFIX_ENTRIES ' By default is TRUE (set in Class_Initialize)
     ' (supressess listing of installed hotfixes)
 Private CLASS_NAME
 Private VERSION
 Private REG_SZ
 Private oReg
 Private sComputerName

 ' --- Public
 Public Function getClassName()
  getClassName = CLASS_NAME
 End Function
 Public Function getVersion()
  getVersion = VERSION
 End Function
 Public Function getList(sHost)
  If TypeName(sHost)="String" AND sHost<>"" Then 
   sComputerName = sHost
  Else
   sComputerName = WScript.CreateObject("WScript.Network").ComputerName
  End If
  On Error Resume Next
  Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" &_
  sComputerName & "/root/default:StdRegProv")
  If Err.Number<>0 Then
   ' Computer is not accessable or does not have WMI, return empty array
   getList = Array()
  Else
   ' Computer is on the network and does have working WMI, 
   ' return the list (safe array) of installed software
   getList = listInstalledProgs(oReg)
  End If
  On Error GoTo 0
 End Function
 Public Function getHostString()
  getHostString = sComputerName
 End Function

 ' --- Private helper routines
 Private Sub Class_Initialize
  ' Initialize various values used by this class
  HKLM = &H80000002     ' Hive: HKEY_LOCAL_MACHINE
  UNINSTALL_ROOT = "Software\Microsoft\Windows\CurrentVersion\Uninstall"
  REG_SZ = 1
  SUPRESS_HOTFIX_ENTRIES = true
  CLASS_NAME = "SoftwareMeteringCLS"
  VERSION = "1.0.3"
 End Sub
 Private Function listInstalledProgs(oReg)
  ' returns array of strings DisplayName & " " & DisplayVersion
  Dim oRegX, nCnt, sSubKeysAry, sProgName
  Dim sProgsAry(): ReDim sProgsAry(1)
  sSubKeysAry = getKeys(oReg, HKLM, UNINSTALL_ROOT)
  If SUPRESS_HOTFIX_ENTRIES Then 
   ' Supress looking into all hot fix related sub keys (like Q252795, etc...)
   Set oRegX = new RegExp
   oRegX.Pattern = "^Q\d+$" ' will detect patterns like: Q252795 
   oRegX.IgnoreCase = true
   For nCnt = 0 To UBound(sSubKeysAry)
    If NOT oRegX.Test(sSubKeysAry(nCnt)) Then
     sProgName = getProgNameAndVersion(oReg, HKLM, _
     UNINSTALL_ROOT & "\" & sSubKeysAry(nCnt))
     If NOT (IsEmpty(sProgName) OR sProgName="") Then
      If NOT IsEmpty(sProgsAry(UBound(sProgsAry) - 1)) Then 
       ReDim Preserve sProgsAry(UBound(sProgsAry)+1)
      End If
      sProgsAry(UBound(sProgsAry)-1) = sProgName
     End If
    End If
   Next
  Else
   ' List all sub keys including hotfix related ones (like Q252795, etc...)
   For nCnt = 0 To UBound(sSubKeysAry)
    sProgName = getProgNameAndVersion(oReg, HKLM, _
    UNINSTALL_ROOT & "\" & sSubKeysAry(nCnt))
    If NOT (IsEmpty(sProgName) OR sProgName="") Then
     If NOT IsEmpty(sProgsAry(UBound(sProgsAry) - 1)) Then 
      ReDim Preserve sProgsAry(UBound(sProgsAry)+1)
     End If
     sProgsAry(UBound(sProgsAry)-1) = sProgName
    End If
   Next
  End If
  listInstalledProgs = sProgsAry
 End Function
 Private Function getKeys(oReg, HIVE, sKeyRoot)
  ' Returns array of strings of subkey names
  Dim vKeysAry
  Call oReg.EnumKey(HIVE, sKeyRoot, vKeysAry)
  getKeys = vKeysAry     ' >>>
 End Function
 Private Function getProgNameAndVersion(oReg, HIVE, sKeyRoot)
  ' If both values "DisplayName" and "DisplayVersion" exist in sKeyRoot, return:
  '  "DisplayNameKeyValue --Version: DisplayVersionKeyValue"
  '
  ' If only "DisplayName" exists, return:
  '  "DisplayNameKeyValue"
  '
  ' Otherwise EMPTY is returned
  Dim sKeyValuesAry, iKeyTypesAry, nCnt, sValue, sDisplayName, sDisplayVersion
  oReg.EnumValues HIVE, sKeyRoot, sKeyValuesAry, iKeyTypesAry 'fill the arrays
  ' 6 Sept 2002
  ' SP3 for Win2K altered behavior of registry provider's EnumValues method!
  ' EnumValues method after SP3 does not return empty array any more for all
  ' those registry keys that have only empty Default value.
  ' Therefore sKeyValuesAry must be tested to see if it is an array or not.
  If NOT IsArray(sKeyValuesAry) Then 
   Exit Function  '                           '   >>>
  End If
  For nCnt = 0 To UBound(sKeyValuesAry)
   If InStr(1, sKeyValuesAry(nCnt), "DisplayName", vbTextCompare) Then
    If iKeyTypesAry(nCnt) = REG_SZ Then
     oReg.GetStringValue HIVE, sKeyRoot, sKeyValuesAry(nCnt), sValue
     If sValue<>"" Then 
      sDisplayName = sValue
      sDisplayName = Replace(sDisplayName, "[", "(")
      sDisplayName = Replace(sDisplayName, "]", ")")
     End If
    End If
   ElseIf InStr(1, sKeyValuesAry(nCnt), "DisplayVersion", vbTextCompare) Then
    If iKeyTypesAry(nCnt) = REG_SZ Then
     oReg.GetStringValue HIVE, sKeyRoot, sKeyValuesAry(nCnt), sValue
     If sValue<>"" Then sDisplayVersion = sValue
    End If
   End If
   If (sDisplayName<>"") AND (sDisplayVersion<>"") Then 
    getProgNameAndVersion = sDisplayName & " --Version: " & sDisplayVersion
    Exit Function    ' >>>
   End If
  Next
  If sDisplayName<>"" Then 
   getProgNameAndVersion = sDisplayName
   Exit Function     ' >>>
  End If
 End Function
End Class
' ====================== END OF CLASS ================================
Function demo_SoftwareMeteringCLS()
 Dim oSoftMeter, sProgsAry, sComputer
 'sComputer = "W-BRANIMIR-666"
 'sComputer = "W-Branimir-079"
 sComputer = "" ' query local host
 sProgsAry = getSoftwareList(sComputer)
 Call WScript.Echo(Join(sProgsAry, vbCrLf))
End Function